
#+ccl (ql:quickload "aserve")

(in-package :cl-user)

(defpackage :web
    (:use :common-lisp
          :common-utils
          :macro-utilities
#+ccl     :net.aserve
    )
    (:shadow :shutdown))

(in-package :web)

(defmacro define-url-function (name (request &rest params) &body body)
    (with-gensyms (entity)
        (let ((params (mapcar #'normalize-param params)))
            `(progn
                (defun ,name (,request ,entity)
                    (with-http-response
                        (,request ,entity :content-type "text/html")
                        (let* (,@(param-bindings name request params))
                            ,@(set-cookies-code name request params)
                            (with-http-body (,request ,entity)
                                (with-html-output
                                    ((request-reply-stream ,request))
                                    (html ,@body))))))
                (publish :path ,(format nil "/~(~A~)" name)
                         :function ',name)))))

(defun normalize-param (param)
    (etypecase param
        (list param)
        (symbol `(,param string nil nil))))

(defun param-bindings (function-name request params)
    (loop for param in params
        collect (param-binding function-name request param)))

(defun param-binding (function-name request param)
    (destructuring-bind (name type &optional default sticky) param
        (let ((query-name (symbol->query-name name))
              (cookie-name (symbol->cookie-name function-name name sticky)))
             `(,name (or (string->type ',type
                                       (request-query-value ,query-name
                                                            ,request))
                         ,@(if cookie-name
                              (list `(string->type
                                        ',type
                                        (get-cookie-value ,request
                                                          ,cookie-name))))
                         ,default)))))

(defgeneric string->type (type value))

(defmethod string->type ((type (eql 'string)) value)
    (and (plusp (length value)) value))

(defmethod string->type((type (eql 'integer)) value)
    (parse-integer (or value "") :junk-allowed t))

(defun get-cookie-value (request name)
    (cdr (assoc name (get-cookie-values request) :test #'string=)))

(defun symbol->query-name (sym) (string-downcase sym))

(defun symbol->cookie-name (function-name sym sticky)
    (let ((package-name (package-name (symbol-package function-name))))
        (when sticky
            (ecase sticky
                (:global (string-downcase sym))
                (:package (format nil "~(~A:~A~)" package-name sym))
                (:local (format nil "~(~A:~A:~A~)" package-name
                                                   function-name sym))))))

(defun set-cookies-code (function-name request params)
    (loop for param in params
        when (set-cookie-code function-name request param) collect it))

(defun set-cookie-code (function-name request param)
    (destructuring-bind (name type &optional default sticky) param
        (declare (ignorable type default))
            (if sticky
                `(when ,name
                    (set-cookie-header
                        ,request
                        :name ,(symbol->cookie-name function-name name sticky)
                        :value (any->string ,name))))))

(show-exports *package*)
